PC Users 1999 May/Cd Pc Users extra 20 mayo 1999.iso/Internet/UDF.BAS

BASIC Source File | 1995-07-25 | 13.9 KB | 516 lines

Option Explicit
Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Declare Function MciExecute Lib "MMSystem" (ByVal CommandString As String) As Integer
Declare Function GetModuleUsage Lib "Kernel" (ByVal hModule As Integer) As Integer
Global Const WM_USER = &H400
Global Const LB_RESET = (WM_USER + 5)
Global Const LB_SETHEXT = (WM_USER + 21)
Global Const LB_GETHEXT = (WM_USER + 20)
Global Const LB_GETITEMH = (WM_USER + 34)
Declare Function SetCapture Lib "User" (ByVal hWnd As Integer) As Integer
Declare Sub ReleaseCapture Lib "User" ()
Type RECT
    Left As Integer
    Top As Integer
    right As Integer
    bottom As Integer
End Type
Declare Sub ClipCursor Lib "User" (lpRect As Any)
Declare Sub GetClientRect Lib "User" (ByVal hWnd As Integer, lpRect As RECT)
Declare Function GetActiveWindow Lib "User" () As Integer
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
Global Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Type PointApi
     X As Integer
     Y As Integer
End Type
Declare Sub GETCURSORPOS Lib "User" (lpPoint As PointApi)
Declare Function sndPlaySound Lib "MMSYSTEM.DLL" (ByVal lpszSoundName$, ByVal Wflags%) As Integer
Global Const SND_SYNC = &H0
Global Const SND_ASYNC = &H1
Global Const SND_NODEFAULT = &H2
Global Const SND_LOOP = &H8
Global Const SND_NOSTOP = &H10
Global V_Reng() As String
Declare Function SetSysModalWindow Lib "User" (ByVal hWnd%) As Integer
Global WPath$

Sub AjustaImg (Img As Image, Arch As String, X As Integer, Y As Integer, AN As Integer, AL As Integer)
    Dim ANP%, ALP%, FACX, FACY
    Img.Visible = False
    Img.Stretch = False
    Img.Picture = LoadPicture(Arch)
    ANP = Img.Width
    ALP = Img.Height
    Img.Stretch = True
    FACX = AN / ANP
    FACY = AL / ALP
    If FACX > FACY Then
    FACX = FACY
    Else
    FACY = FACX
    End If
    Img.Width = (ANP * FACX)
    Img.Height = (ALP * FACY)
    Img.Left = X + (AN - Img.Width) / 2
    Img.Top = Y + (AL - Img.Height) / 2
    'Img.Visible = True
End Sub

Sub AjustaImgFX (Img As Control, Arch As String, X As Integer, Y As Integer, AN As Integer, AL As Integer, ImgDummy As Control)
    Dim ANP%, ALP%, FACX, FACY, WTag$
    Img.FileName = ""
    Img.Visible = True
    Img.AutoSize = 1
    Img.FileName = Arch
    Img.Refresh
    Img.Visible = False
    'ImgDummy.Visible = False
    'ImgDummy.Stretch = False
    'ImgDummy.Picture = LoadPicture(Arch)
    ANP = Img.Width
    ALP = Img.Height
    Img.FileName = ""
    'ImgDummy.Picture = LoadPicture()
    WTag = "T:" + Trim(Str$(FileLen(Arch)))
    WTag = WTag + "/" + "H:" + Trim(Str$(ALP))
    WTag = WTag + "/" + "W:" + Trim(Str$(ANP))
    Img.Tag = WTag
    'Img.Stretch = True
    FACX = AN / ANP
    FACY = AL / ALP
    If FACX > FACY Then
    FACX = FACY
    Else
    FACY = FACX
    End If
    Img.Width = (ANP * FACX)
    Img.Height = (ALP * FACY)
    Img.Left = X + (AN - Img.Width) / 2
    Img.Top = Y + (AL - Img.Height) / 2
    'Img.Refresh
    Img.AutoSize = 2
    'Img.Picture = LoadPicture(Arch)
    Img.FileName = Arch
    'Img.Visible = True
End Sub

Sub Alinear (Cual As Control, Concual As Control)
    Cual.Top = Concual.Top
    Cual.Left = Concual.Left
End Sub

Sub Center (quien As Control)
    quien.Height = 480
    quien.Width = 640
    quien.Top = (screen.Height / screen.TwipsPerPixelY - quien.Height) / 2
    quien.Left = (screen.Width / screen.TwipsPerPixelX - quien.Width) / 2
End Sub

Sub CenterSize (quien As Control)
    quien.Top = (screen.Height / screen.TwipsPerPixelY - quien.Height) / 2
    quien.Left = (screen.Width / screen.TwipsPerPixelX - quien.Width) / 2
End Sub

Sub CopiaFon (Source As PictureBox, Dest As PictureBox)
    Dim A As Integer
    Dim A1%, A2%
    A1 = Source.AutoRedraw
    A2 = Dest.AutoRedraw
    Source.AutoRedraw = True
    Dest.AutoRedraw = True
    A = BitBlt(Dest.hDC, 0, 0, Dest.Width, Dest.Height, Source.hDC, Dest.Left, Dest.Top, SRCCOPY)
    Source.AutoRedraw = A1
    Dest.AutoRedraw = A2
End Sub

Sub CopiaPic (Source As PictureBox, Dest As PictureBox)
    Dim A As Integer
    Dim A1, A2
    A1 = Source.AutoRedraw
    A2 = Dest.AutoRedraw
    Source.AutoRedraw = True
    Dest.AutoRedraw = True
    A = BitBlt(Dest.hDC, 0, 0, Source.Width, Source.Height, Source.hDC, 0, 0, SRCCOPY)
    Source.AutoRedraw = A1
    Dest.AutoRedraw = A2
End Sub

Function DirWin () As String
    Dim WinDir$, I%
    WinDir$ = Space$(144)
    I = GetWindowsDirectory(WinDir$, 144)
    If I = 0 Then
    DirWin = ""
    Else
    WinDir$ = TTrim$(WinDir$)
    If Right(WinDir$, 1) <> "\" Then
    WinDir$ = WinDir$ + "\"
    End If
    DirWin = WinDir$
    End If
End Function

Function DirWinS () As String
    Dim WinSysDir$, I%
    WinSysDir$ = Space$(144)
    I = GetSystemDirectory(WinSysDir$, 144)
    If I = 0 Then
    DirWinS = ""
    Else
    WinSysDir$ = TTrim$(WinSysDir$)
    If Right(WinSysDir$, 1) <> "\" Then
        WinSysDir$ = WinSysDir$ + "\"
    End If
    DirWinS = WinSysDir$
    End If
End Function

Sub DividirTXT (Wtext As String, Crengs As Integer, ThePicture As PictureBox, Offset As Integer)
    Dim StringtoPrint As String
    Dim NextWord As String
    Dim AcLength As Integer
    Dim X As Integer
    ThePicture.CurrentX = Offset
    ThePicture.CurrentY = Offset
    ReDim V_Reng(1)
    StringtoPrint = Wtext
    AcLength = Offset
    NextWord = SacaPal(StringtoPrint)
    X = 1
    Do While NextWord <> ""
    If ((AcLength + ThePicture.TextWidth(NextWord)) > ThePicture.ScaleWidth) Then
        X = X + 1
        ReDim Preserve V_Reng(X)
        AcLength = Offset + ThePicture.TextWidth(NextWord)
      Else
        AcLength = AcLength + ThePicture.TextWidth(NextWord)
    End If
    If Left$(NextWord, 2) = Chr$(10) + Chr$(13) Or Left$(NextWord, 2) = Chr$(13) + Chr$(10) Then
        X = X + 1
        ReDim Preserve V_Reng(X)
        NextWord = Mid$(NextWord, 3)
        AcLength = Offset + ThePicture.TextWidth(NextWord)
    End If
    V_Reng(X) = V_Reng(X) + NextWord
    NextWord = SacaPal(StringtoPrint)
    Loop
    X = X + 1
    ReDim Preserve V_Reng(X)
    V_Reng(X) = "~EOF~"
    Crengs = X - 1
End Sub

Sub Emilinea (Texto As String, Pic As PictureBox, Reng As Integer, Col As Long, Offs As Integer)
    Dim X As Integer
    Dim Cant As Long
    Pic.CurrentX = 0
    Pic.CurrentY = 0
    For X = 1 To Reng - 1
    Pic.Print
    Next X
    Cant = Pic.ForeColor
    Pic.ForeColor = Col
    Pic.CurrentX = Offs
    Pic.Print Texto
    Pic.ForeColor = Cant
End Sub

Function FMes (Cual) As String
    Select Case Cual
    Case 1
        FMes = "Enero"
    Case 2
        FMes = "Febrero"
    Case 3
        FMes = "Marzo"
    Case 4
        FMes = "Abril"
    Case 5
        FMes = "Mayo"
    Case 6
        FMes = "Junio"
    Case 7
        FMes = "Julio"
    Case 8
        FMes = "Agosto"
    Case 9
        FMes = "Septiembre"
    Case 10
        FMes = "Octubre"
    Case 11
        FMes = "Noviembre"
    Case 12
        FMes = "Diciembre"
    End Select
End Function

Function FWPath () As String
    Dim WPath$
    WPath = app.Path
    If Right$(WPath, 1) <> "\" Then
    WPath = WPath + "\"
    End If
    FWPath = WPath
End Function

Sub PlaySnd (Cual As String)
    Dim A%, Wflags%
    Wflags% = SND_ASYNC Or SND_NODEFAULT
    A% = sndPlaySound(Cual, Wflags%)
End Sub

Sub PlaySndNS (Cual As String)
    Dim A%, Wflags%
    Wflags% = SND_SYNC Or SND_NODEFAULT
    A% = sndPlaySound(Cual, Wflags%)
End Sub

Sub PlaySndR (Cual As String)
    Dim A%, Wflags%
    Wflags% = SND_ASYNC Or SND_NODEFAULT Or SND_LOOP
    A% = sndPlaySound(Cual, Wflags%)
End Sub

Sub PrCenter (Wstr As String, Pic As PictureBox, Reng As Integer, Col As Long)
    Dim X As Integer, L%
    Dim Cant As Long
    Pic.CurrentX = 0
    Pic.CurrentY = 0
    For X = 1 To Reng - 1
    Pic.Print
    Next X
    Cant = Pic.ForeColor
    Pic.ForeColor = Col
    L = Pic.TextWidth(Wstr)
    X = Int((Pic.ScaleWidth - L) / 2)
    Pic.CurrentX = X
    Pic.Print Wstr
    Pic.ForeColor = Cant
End Sub

Sub PrintPic (Texto As String, ThePicture As PictureBox, OffSetX As Integer, OffSetY As Integer, MX%, MY%)
    Dim StringtoPrint As String
    Dim NextWord As String
    Dim AcLength As Integer
    StringtoPrint = Texto
    ThePicture.Cls
    ThePicture.CurrentX = OffSetX
    ThePicture.CurrentY = OffSetY
    If MX = 0 Then
    MX = ThePicture.ScaleWidth
    End If
    If MY = 0 Then
    MY = ThePicture.ScaleHeight
    End If
    AcLength = OffSetX
    NextWord = SacaPal(StringtoPrint)
    Do While NextWord <> ""
    If ((AcLength + ThePicture.TextWidth(NextWord)) > MX) Then
        ThePicture.Print
        ThePicture.CurrentX = OffSetX
        AcLength = OffSetX + ThePicture.TextWidth(NextWord)
      Else
        AcLength = AcLength + ThePicture.TextWidth(NextWord)
    End If
    Do While Left$(NextWord, 2) = Chr$(10) + Chr$(13) Or Left$(NextWord, 2) = Chr$(13) + Chr$(10)
        ThePicture.Print
        If ThePicture.CurrentY > MY Then
        Exit Sub
        End If
        ThePicture.CurrentX = OffSetX
        NextWord = Mid$(NextWord, 3)
        AcLength = OffSetX + ThePicture.TextWidth(NextWord)
    Loop
    ThePicture.Print NextWord;
    NextWord = SacaPal(StringtoPrint)
    Loop
End Sub

Sub PrintPicP (Texto As String)
    Dim StringtoPrint As String
    Dim NextWord As String
    Dim AcLength As Integer
    Dim Offset%
    StringtoPrint = Texto
    Offset = 0
    Printer.CurrentX = Offset
    Printer.CurrentY = Offset
    AcLength = Offset
    NextWord = SacaPal(StringtoPrint)
    Do While NextWord <> ""
    If ((AcLength + Printer.TextWidth(NextWord)) > Printer.ScaleWidth) Then
        Printer.Print
        Printer.CurrentX = Offset
        AcLength = Offset + Printer.TextWidth(NextWord)
      Else
        AcLength = AcLength + Printer.TextWidth(NextWord)
    End If
    If Left$(NextWord, 2) = Chr$(10) + Chr$(13) Or Left$(NextWord, 2) = Chr$(13) + Chr$(10) Then
        Printer.Print
        Printer.CurrentX = Offset
        NextWord = Mid$(NextWord, 3)
        AcLength = Offset + Printer.TextWidth(NextWord)
    End If
    Printer.Print NextWord;
    NextWord = SacaPal(StringtoPrint)
    Loop
End Sub

Sub PrintPicR (PR As Integer, CR As Integer, ThePicture As PictureBox, Offset As Integer)
    Dim X As Integer
    ThePicture.Cls
    ThePicture.CurrentY = Offset
    For X = PR To PR + CR - 1
    If V_Reng(X) = "~EOF~" Then
        Exit For
    End If
    ThePicture.CurrentX = Offset
    ThePicture.Print V_Reng(X)
    Next X
End Sub

Function SacaPal (AnyString As String) As String
    Dim WRet$, Wenter$, P1%, P2%, Pos%, Espacio%
    Wenter$ = Chr(13) + Chr(10)
    P2 = InStr(AnyString, " ")
    P1 = InStr(AnyString, Wenter)
    If P1 = P2 Then
    WRet = AnyString
    AnyString = ""
    Else
    If P2 < P1 Then
        Espacio = (P2 <> 0)
    Else
        Espacio = (P1 = 0)
    End If
    If Not Espacio Then 'Primero el <Enter>
        If P1 = 1 Then
        WRet = Wenter$
        AnyString = Mid$(AnyString, 3)
        Else
        WRet = Left$(AnyString, P1 - 1)
        AnyString = Mid$(AnyString, P1)
        End If
    Else
        WRet = Left$(AnyString, P2)
        AnyString = Mid$(AnyString, P2 + 1)
    End If
    End If
    SacaPal = WRet
End Function

Function Sinext (DeQue As String) As String
    Dim N%
    N% = InStr(DeQue, ".")
    If N% = 0 Then
    Sinext = Trim$(DeQue)
    Else
    Sinext = Left$(Trim$(DeQue), N - 1)
    End If
End Function

Function SinPath (WDeQue$) As String
    Dim WRet$, L$, P, DeQue$
    DeQue = Trim$(WDeQue)
    If Right(WDeQue, 1) = "\" Then
    WDeQue = Left(WDeQue, Len(WDeQue) - 1)
    End If
    WRet = ""
    P = Len(DeQue)
    Do While P <> 0
    L = Mid$(DeQue, P, 1)
    If L = "\" Then
        WRet = Mid(DeQue, P + 1)
        Exit Do
    End If
    P = P - 1
    Loop
    SinPath = WRet
End Function

Function StrTr (AQue$, Que$, ConQue$) As String
    Dim WRet$, P%
    WRet$ = AQue$
    P = InStr(1, WRet$, Que$)
    Do Until P = 0
    WRet$ = Left$(WRet$, P - 1) + ConQue$ + Mid$(WRet$, P + Len(Que$))
    P = P + Len(Que$)
    P = InStr(P, WRet$, Que$)
    Loop
    StrTr = WRet$
End Function

Function StrTran (Inp As String, Cual As String, Concual As String) As String
    Dim C$, X%, L%, WRet$
    WRet$ = ""
    L% = Len(Inp$)
    For X = 1 To L%
    C = Mid$(Inp, X, 1)
    If C = Cual Then
        WRet$ = WRet$ + Concual
    Else
        WRet$ = WRet$ + C
    End If
    Next
    StrTran = WRet
End Function

Function Truncado (QueStr As String, Pbox As Control, Longi As Integer) As String
    Dim N%, WRet$, L%, Pala$, Orig$
    WRet$ = ""
    If Pbox.TextWidth(Trim$(QueStr)) < Longi Then
    Truncado = Trim$(QueStr)
    Else
    Orig$ = QueStr
    N = Longi - Pbox.TextWidth("...") - 2
    L% = 0
    Pala = ""
    Do While L% < N%
        WRet = WRet + Pala
        Pala = SacaPal(Orig)
        L = Pbox.TextWidth(Trim(WRet + Pala))
    Loop
    WRet = Trim(WRet) + "..."
    Truncado = WRet
    End If
End Function

Function TTrim$ (Incoming$)
    Dim Temp$, I%
    Temp$ = Incoming$
    I% = InStr(Temp$, Chr$(0))
    If I% <> 0 Then
    Temp$ = Left$(Temp$, I% - 1)
    End If
    Temp$ = LTrim$(RTrim$(Temp$))
    TTrim$ = Temp$
End Function

Function Unif (Loque As String) As String
    Unif = RTrim$(LTrim$(UCase$(Loque)))
End Function

Function ValidPath (DeQue$) As String
    Dim WRet$, P%, Aux$, K%, L$
    Aux = DeQue
    P = InStr(3, Aux, "\..")
    Do While P <> 0
    If P <> 1 Then
        K = P
        L$ = Mid(Aux, K - 1, 1)
        Do While L <> "\"
        K = K - 1
        L$ = Mid(Aux, K, 1)
        Loop
        Aux = Left(Aux, K - 1) + Mid$(Aux, P + 3)
    End If
    P = InStr(3, Aux, "\..")
    Loop
    WRet = Aux
    ValidPath = WRet
End Function